home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / forth / pfe-0.000 / pfe-0 / pfe-0.9.13 / src / lpf83.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-07-17  |  6.3 KB  |  296 lines
  1. /*
  2.  * This file is part of the portable Forth environment written in ANSI C.
  3.  * Copyright (C) 1995  Dirk Uwe Zoller
  4.  *
  5.  * This library is free software; you can redistribute it and/or
  6.  * modify it under the terms of the GNU Library General Public
  7.  * License as published by the Free Software Foundation; either
  8.  * version 2 of the License, or (at your option) any later version.
  9.  *
  10.  * This library is distributed in the hope that it will be useful,
  11.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  13.  * See the GNU Library General Public License for more details.
  14.  *
  15.  * You should have received a copy of the GNU Library General Public
  16.  * License along with this library; if not, write to the Free
  17.  * Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  *
  19.  * This file is version 0.9.13 of 17-July-95
  20.  * Check for the latest version of this package via anonymous ftp at
  21.  *    roxi.rz.fht-mannheim.de:/pub/languages/forth/pfe-VERSION.tar.gz
  22.  * or    sunsite.unc.edu:/pub/languages/forth/pfe-VERSION.tar.gz
  23.  * or    ftp.cygnus.com:/pub/forth/pfe-VERSION.tar.gz
  24.  *
  25.  * Please direct any comments via internet to
  26.  *    duz@roxi.rz.fht-mannheim.de.
  27.  * Thank You.
  28.  */
  29. /*
  30.  * lpf83.c ---        Compatibility with Laxen&Perry's F83.
  31.  *
  32.  *              There are lots of useful words in F83 that do not appear
  33.  *              in any standard. This file defines some of them.
  34.  *
  35.  * (duz 06Sep93)
  36.  */
  37.  
  38. #include "forth.h"
  39. #include "support.h"
  40. #include "compiler.h"
  41.  
  42. #include <string.h>
  43. #include <ctype.h>
  44.  
  45. #include "missing.h"
  46.  
  47. /************************************************************************/
  48. /* from KERNEL86.BLK                                                    */
  49. /************************************************************************/
  50.  
  51. Code (bounds)            /* BOUNDS */
  52. {
  53.   Cell h = sp[1];
  54.  
  55.   sp[1] += sp[0];
  56.   sp[0] = h;
  57. }
  58.  
  59. Code (perform)            /* PERFORM ( addr --- ) */
  60. {                /* same as `@ EXECUTE' */
  61.   execute (*(Xt *) *sp++);
  62. }
  63.  
  64. Code (question_leave)        /* ?LEAVE */
  65. {
  66.   if (*sp++)
  67.     {
  68.       ip = rp[2] - 1;
  69.       rp += 3;
  70.       BRANCH;
  71.     }
  72. }
  73.  
  74. code (noop)
  75. {
  76. }
  77.  
  78. Code (r_p_fetch)        /* RP@ (--- addr) */
  79. {                /* returns return stack pointer */
  80.   *--sp = (Cell) rp;
  81. }
  82.  
  83. Code (r_p_store)        /* RP! (addr ---) */
  84. {                /* sets return stack pointer */
  85.   rp = (Xt **) *sp++;
  86. }
  87.  
  88. Code (s_p_store)        /* SP! (... addr ---) */
  89. {                /* sets stack pointer */
  90.   sp = *(Cell **) sp;
  91. }
  92.  
  93. Code (dash_rot)            /* -ROT */
  94. {
  95.   Cell h = sp[2];
  96.  
  97.   sp[2] = sp[0];
  98.   sp[0] = sp[1];
  99.   sp[1] = h;
  100. }
  101.  
  102. Code (c_set)            /* CSET ( n addr --- ) */
  103. {                /* set bits in byte at given address */
  104.   *(char *) sp[0] |= (char) sp[1];
  105.   sp += 2;
  106. }
  107.  
  108. Code (c_reset)            /* CRESET ( n addr --- ) */
  109. {                /* reset bits in byte at given address */
  110.   *(char *) sp[0] &= ~(char) sp[1];
  111.   sp += 2;
  112. }
  113.  
  114. Code (c_toggle)            /* CTOGGLE ( n addr --- ) */
  115. {                /* toggle bits in byte at given address */
  116.   *(char *) sp[0] ^= (char) sp[1];
  117.   sp += 2;
  118. }
  119.  
  120. Code (off)            /* OFF */
  121. {
  122.   *(Cell *) *sp++ = FALSE;
  123. }
  124.  
  125. Code (on)            /* ON */
  126. {
  127.   *(Cell *) *sp++ = TRUE;
  128. }
  129.  
  130. Code (three_dup)        /* 3DUP */
  131. {
  132.   sp -= 3;
  133.   sp[0] = sp[3];
  134.   sp[1] = sp[4];
  135.   sp[2] = sp[5];
  136. }
  137.  
  138. Code (four_dup)            /* 4DUP */
  139. {
  140.   sp -= 4;
  141.   sp[0] = sp[4];
  142.   sp[1] = sp[5];
  143.   sp[2] = sp[6];
  144.   sp[3] = sp[7];
  145. }
  146.  
  147. Code (upc)            /* UPC ( c1 --- c2 ) */
  148. {                /* convert single character to upper case */
  149.   *sp = toupper (*sp);
  150. }
  151.  
  152. Code (upper)            /* UPPER ( addr cnt --- ) */
  153. {                /* convert string to upper case */
  154.   upper ((char *) sp[1], sp[0]);
  155.   sp += 2;
  156. }
  157.  
  158. /* This is not in L&P's F83 but provided for symmetry: */
  159. Code (lower)            /* LOWER ( addr cnt --- ) */
  160. {                /* convert string to lower case */
  161.   lower ((char *) sp[1], sp[0]);
  162.   sp += 2;
  163. }
  164.  
  165. Code (skip)            /* SKIP ( addr cnt c --- addr' cnt' ) */
  166. {                /* skip leading characters c */
  167.   char *p = (char *) sp[2];
  168.   Cell n = sp[1];
  169.   char c = (char) *sp++;
  170.  
  171.   while (n && *p == c)
  172.     n--, p++;
  173.   sp[1] = (Cell) p;
  174.   sp[0] = n;
  175. }
  176.  
  177. Code (scan)            /* SCAN ( addr cnt c --- addr' cnt' ) */
  178. {                /* scan for first occurence of c in string */
  179.   char *p = (char *) sp[2];
  180.   Cell n = sp[1];
  181.   char c = (char) *sp++;
  182.  
  183.   while (n && *p != c)
  184.     n--, p++;
  185.   sp[1] = (Cell) p;
  186.   sp[0] = n;
  187. }
  188.  
  189. Code (place)            /* PLACE ( addr1 len addr2 --- ) */
  190. {                /* store string addr1/len at addr2 */
  191.   Byte *p = (Byte *) sp[0];
  192.  
  193.   *p = sp[1];
  194.   memcpy ((Byte *) sp[2], p + 1, *p);
  195.   sp += 3;
  196. }
  197.  
  198. Code (ascii)            /* state smart version of CHAR/[CHAR] */
  199. {
  200.   char *p;
  201.   uCell n;
  202.  
  203.   skip_delimiter (' ');
  204.   parse (' ', &p, &n);
  205.   if (n == 0)
  206.     tHrow (THROW_INVALID_NAME);
  207.   if (STATE)
  208.     {
  209.       compile1 ();
  210.       COMMA (*(Byte *) p);
  211.     }
  212.   else
  213.     *--sp = *(Byte *) p;
  214. }
  215. COMPILES (ascii, literal_execution,
  216.       SKIPS_CELL, DEFAULT_STYLE);
  217.  
  218. Code (control)            /* like ASCII but returns char - '@' */
  219. {
  220.   char *p;
  221.   uCell c;
  222.   uCell n;
  223.  
  224.   skip_delimiter (' ');
  225.   parse (' ', &p, &n);
  226.   if (n == 0)
  227.     tHrow (THROW_INVALID_NAME);
  228.   c = *(Byte *) p;
  229.   if ('@' <= c && c <= '_')
  230.     c -= '@';
  231.   if (STATE)
  232.     {
  233.       compile1 ();
  234.       COMMA (c);
  235.     }
  236.   else
  237.     *--sp = c;
  238. }
  239. COMPILES (control, literal_execution,
  240.       SKIPS_CELL, DEFAULT_STYLE);
  241.  
  242. Code (number_question)        /* NUMBER? ( addr --- d flag ) */
  243. {                /* convert counted string to number */
  244.   char *p = (char *) *sp;
  245.  
  246.   sp -= 2;
  247.   sp[0] = number_question (p + 1, *(Byte *) p, (dCell *) &sp[1]);
  248. }
  249.  
  250. /************************************************************************/
  251. /* from EXTEND86.BLK                                                    */
  252. /************************************************************************/
  253.  
  254. Code (vocs)            /* VOCS */
  255. {
  256.   Wordl *wl = VOC_LINK;
  257.  
  258.   while (wl != NULL)
  259.     {
  260.       dot_name (to_name (BODY_FROM (wl)));
  261.       wl = wl->prev;
  262.     }
  263. }
  264.  
  265. /* *INDENT-OFF* */
  266. LISTWORDS (lpf83) =
  267. {
  268.   OC ("BS",        '\b'),
  269.   CO ("BOUNDS",        bounds),
  270.   CO ("PERFORM",    perform),
  271.   CO ("?LEAVE",        question_leave),
  272.   CO ("NOOP",        noop),
  273.   CO ("RP@",        r_p_fetch),
  274.   CO ("RP!",        r_p_store),
  275.   CO ("SP!",        s_p_store),
  276.   CO ("-ROT",        dash_rot),
  277.   CO ("CSET",        c_set),
  278.   CO ("CRESET",        c_reset),
  279.   CO ("CTOGGLE",    c_toggle),
  280.   CO ("OFF",        off),
  281.   CO ("ON",        on),
  282.   CO ("3DUP",        three_dup),
  283.   CO ("4DUP",        four_dup),
  284.   CO ("UPC",        upc),
  285.   CO ("UPPER",        upper),
  286.   CO ("LOWER",        lower),
  287.   CO ("SKIP",        skip),
  288.   CO ("SCAN",        scan),
  289.   CO ("PLACE",        place),
  290.   CS ("ASCII",        ascii),
  291.   CS ("CONTROL",    control),
  292.   CO ("NUMBER?",    number_question),
  293.   CO ("VOCS",        vocs),
  294. };
  295. COUNTWORDS (lpf83, "L&P F83 compatiblity");
  296.